home *** CD-ROM | disk | FTP | other *** search
/ Magnum One / Magnum One (Mid-American Digital) (Disc Manufacturing).iso / d18 / ansi_130.arc / PINGANSI.PAS < prev    next >
Pascal/Delphi Source File  |  1991-04-28  |  16KB  |  528 lines

  1. {$DEFINE Music}
  2. {$DEFINE BBS}
  3. {$UNDEF Small}
  4. { $A+,B-,D-,E-,F+,I-,L-,O+,R-,S-,V-}
  5. (*
  6.      PingAnsi v 1.30 (c) CopyRight 1990 P.H.Rankin Hansen.
  7.  
  8.      This unit provides partial Ansi emulation for Turbo Pascal versions
  9.      5.x and higher. (version 4 does not support procedural types). Some
  10.      routines are handled in a non-standard way.
  11.  
  12.      Released in Denmark on June 3rd 1990.
  13.  
  14.      By  using  this  material  You  assume  FULL responsibility for ANY
  15.      consequences  -  direct  or   indirect  -  thereof.
  16.      Any dispute regarding this material shall be setteled by Danish law
  17.      and in a Danish Court.
  18.  
  19.      (Sigh!)
  20.  
  21.      This  source may  NOT be  used by  Lawyers, Politicians or, persons
  22.      engaged  in any  other form  of terrorism.  Otherwise the  usage is
  23.      free.
  24.  
  25.      This source may be freely distributed as long as no fee is charged.
  26.  
  27.      Please direct any comments,  corrections, modifications via netmail
  28.      to:
  29.  
  30.                       Ping Hansen - Fido Net 2:231/62.58
  31.  
  32. *)
  33.  
  34. Unit PingAnsi;
  35.   {-}
  36. Interface
  37. Uses
  38.  
  39.   { Standard units }
  40.   Dos,
  41.   { Turbo Power units. The standard CRT unit will not work in a TSR }
  42.   TpCrt, TpString;
  43.  
  44. Const
  45.   Title               = 'PingAnsi v1.30 (c) CopyRight P.H.Rankin Hansen 1990.';
  46.  
  47. Var
  48.   Ansi                : Text;     { Ansi is the name of the device }
  49.   Wrap                : Boolean;  { True if Cursor should wrap }
  50.   ReportedX,
  51.   ReportedY           : Word;     { X,Y reported }
  52.  
  53.   { hook for implementing Your own Device Status Report procedure }
  54.   ReplyHook           : Procedure(St : String);
  55.  
  56.   { hook for implementing Your own KeyBoard ReAssignment }
  57.   KeyHook             : Procedure(St : String);
  58.  
  59.   { Hook for handling control chars i.e. Ch < Space }
  60.   WriteHook           : Procedure(Ch : Char);
  61.  
  62.   {$IFNDEF Small}
  63.   {$IFDEF BBS}
  64.  
  65.   { Hook for handling simultaneous writes to ComPort and Screen }
  66.   BBsHook       : Procedure (Ch : Char);
  67.  
  68.   {$ENDIF}
  69.   {$ENDIF}
  70.  
  71.   {$IFDEF Music}
  72.  
  73.   { Hook for handling music }
  74.   PlayHook  : Procedure(St : String);
  75.  
  76.   {$ENDIF}
  77.  
  78. Function In_Ansi    : Boolean;    { True if a sequence is pending }
  79. Procedure AnsiWrite(Ch : Char);
  80.  
  81.   {$IFNDEF Small}
  82.  
  83. Procedure AssignAnsi(Var f : Text); { use like AssignCrt }
  84.  
  85.   {$ENDIF}
  86.  
  87. Implementation
  88.  
  89. Type
  90.   States              = (Waiting, Bracket, Get_Args, Get_Param, Eat_Semi,
  91.                          Get_String, In_Param, Get_Music);
  92. Const
  93.   St                  : String = '';
  94.   ParamArr            : Array[1..10] Of Word = (0, 0, 0, 0, 0, 0, 0, 0, 0, 0);
  95.   Params              : Word = 0; { number of parameters }
  96.   NextState           : States = Waiting; { next state for the parser }
  97.   Reverse             : Boolean = False; { true if text attributes are reversed }
  98.  
  99. Var
  100.   Quote               : Char;
  101.   SavedX, SavedY      : Word;
  102.  
  103.   Function In_Ansi    : Boolean;  { True if a sequence is pending }
  104.   Begin
  105.     In_Ansi := (NextState <> Waiting) And (NextState <> Bracket);
  106.   End {In_Ansi} ;
  107.  
  108.  
  109.   {$F+}
  110.   Procedure Report(St : String);
  111.     {$F-}
  112.   Begin
  113.     StuffString(St);
  114.   End;
  115.  
  116.   {$F+}
  117.   Procedure WriteChar(Ch : Char);
  118.     {$F-}
  119.   Begin
  120.     Case Ch Of
  121.       #7 :
  122.         Begin
  123.           NoSound;
  124.           Sound(500);
  125.           Delay(50);
  126.           NoSound;
  127.           Delay(50);
  128.         End;
  129.       #8 : If (WhereX > 1) Then Write(#8' '#8);
  130.       #9 : If (WhereX < 71) Then
  131.            Repeat
  132.              GotoXy(WhereX + 1, Wherey);
  133.            Until (WhereX Mod 8 = 1);
  134.       Else
  135.         Write(Ch);
  136.     End {Case} ;
  137.   End {WriteChar} ;
  138.  
  139.   {$F+}
  140.   Procedure Dummy(St : String);
  141.     {$F-}
  142.   Begin
  143.   End;
  144.  
  145.   Procedure AnsiWrite(Ch : Char);
  146.  
  147.   Var
  148.     i                   : Word;
  149.  
  150.   Label Command;
  151.  
  152.   Begin
  153.     If Ch = #27 Then
  154.     Begin
  155.       NextState := Bracket;
  156.       Exit;
  157.     End;
  158.     Case NextState Of
  159.       Waiting : If (Ch > ' ') Then Write(Ch)
  160.                 Else WriteHook(Ch);
  161.       Bracket :
  162.         Begin
  163.           If Ch <> '[' Then
  164.           Begin
  165.             NextState := Waiting;
  166.             If (Ch > ' ') Then Write(Ch)
  167.             Else WriteHook(Ch);
  168.             Exit;
  169.           End;
  170.           St := '';
  171.           Params := 1;
  172.           FillChar(ParamArr, 10, 0);
  173.           NextState := Get_Args;
  174.         End;
  175.       Get_Args, Get_Param, Eat_Semi :
  176.         Begin
  177.           {$IFNDEF Music}
  178.           If (NextState = Get_Args) And ((Ch = '=') Or (Ch = '?')) Then
  179.           Begin
  180.             NextState := Get_Param;
  181.             Exit;
  182.           End;
  183.           {$ELSE}
  184.           If (NextState = Get_Args) Then
  185.             Case Ch Of
  186.               '=', '?' :
  187.                 Begin
  188.                   NextState := Get_Param;
  189.                   Exit;
  190.                 End;
  191.               'M' :
  192.                 Begin
  193.                   NextState := Get_Music;
  194.                   Exit;
  195.                 End;
  196.             End {Case} ;
  197.           {$ENDIF}
  198.           If (NextState = Eat_Semi) And (Ch = ';') Then
  199.           Begin
  200.             If Params < 10 Then Inc(Params);
  201.             NextState := Get_Param;
  202.             Exit;
  203.           End;
  204.           Case Ch Of
  205.             '0'..'9' :
  206.               Begin
  207.                 ParamArr[Params] := Ord(Ch) - Ord('0');
  208.                 NextState := In_Param;
  209.               End;
  210.             ';' :
  211.               Begin
  212.                 If Params < 10 Then Inc(Params);
  213.                 NextState := Get_Param;
  214.               End;
  215.             '"', '''' :
  216.               Begin
  217.                 Quote := Ch;
  218.                 St := St + Ch;
  219.                 NextState := Get_String;
  220.               End;
  221.             Else
  222.               GoTo Command;
  223.           End {Case Ch} ;
  224.         End;
  225.       Get_String :
  226.         Begin
  227.           St := St + Ch;
  228.           If Ch <> Quote
  229.           Then NextState := Get_String
  230.           Else NextState := Eat_Semi;
  231.         End;
  232.       In_Param :                  { last char was a digit }
  233.         Begin
  234.           { looking for more digits, a semicolon, or a command char }
  235.           Case Ch Of
  236.             '0'..'9' :
  237.               Begin
  238.                 ParamArr[Params] := ParamArr[Params] * 10 + Ord(Ch) - Ord('0');
  239.                 NextState := In_Param;
  240.                 Exit;
  241.               End;
  242.             ';' :
  243.               Begin
  244.                 If Params < 10 Then Inc(Params);
  245.                 NextState := Eat_Semi;
  246.                 Exit;
  247.               End;
  248.           End {Case Ch} ;
  249. Command:
  250.           NextState := Waiting;
  251.           Case Ch Of
  252.             { Note: the order of commands is optimized for execution speed }
  253.             'm' :                 {sgr}
  254.               Begin
  255.                 For i := 1 To Params Do
  256.                 Begin
  257.                   If Reverse Then TextAttr := TextAttr Shr 4 + TextAttr Shl 4;
  258.                   Case ParamArr[i] Of
  259.                     0 :
  260.                       Begin
  261.                         Reverse := False;
  262.                         TextAttr := 7;
  263.                       End;
  264.                     1 : TextAttr := TextAttr And $FF Or $08;
  265.                     2 : TextAttr := TextAttr And $F7 Or $00;
  266.                     4 : TextAttr := TextAttr And $F8 Or $01;
  267.                     5 : TextAttr := TextAttr Or $80;
  268.                     7 : If Not Reverse Then
  269.                         Begin
  270.                       {
  271.                       TextAttr := TextAttr shr 4 + TextAttr shl 4;
  272.                       }
  273.                           Reverse := True;
  274.                         End;
  275.                     22 : TextAttr := TextAttr And $F7 Or $00;
  276.                     24 : TextAttr := TextAttr And $F8 Or $04;
  277.                     25 : TextAttr := TextAttr And $7F Or $00;
  278.                     27 : If Reverse Then
  279.                          Begin
  280.                            Reverse := False;
  281.                       {
  282.                       TextAttr := TextAttr shr 4 + TextAttr shl 4;
  283.                       }
  284.                          End;
  285.                     30 : TextAttr := TextAttr And $F8 Or $00;
  286.                     31 : TextAttr := TextAttr And $F8 Or $04;
  287.                     32 : TextAttr := TextAttr And $F8 Or $02;
  288.                     33 : TextAttr := TextAttr And $F8 Or $06;
  289.                     34 : TextAttr := TextAttr And $F8 Or $01;
  290.                     35 : TextAttr := TextAttr And $F8 Or $05;
  291.                     36 : TextAttr := TextAttr And $F8 Or $03;
  292.                     37 : TextAttr := TextAttr And $F8 Or $07;
  293.                     40 : TextAttr := TextAttr And $8F Or $00;
  294.                     41 : TextAttr := TextAttr And $8F Or $40;
  295.                     42 : TextAttr := TextAttr And $8F Or $20;
  296.                     43 : TextAttr := TextAttr And $8F Or $60;
  297.                     44 : TextAttr := TextAttr And $8F Or $10;
  298.                     45 : TextAttr := TextAttr And $8F Or $50;
  299.                     46 : TextAttr := TextAttr And $8F Or $30;
  300.                     47 : TextAttr := TextAttr And $8F Or $70;
  301.                   End {Case} ;
  302.                   { fixup for reverse }
  303.                   If Reverse Then TextAttr := TextAttr Shr 4 + TextAttr Shl 4;
  304.                 End;
  305.               End;
  306.             'A' :                 {cuu}
  307.               Begin
  308.                 If ParamArr[1] = 0 Then ParamArr[1] := 1;
  309.                 If (Wherey - ParamArr[1] >= 1)
  310.                 Then GotoXy(WhereX, Wherey - ParamArr[1])
  311.                 Else GotoXy(WhereX, Hi(WindMax));
  312.               End;
  313.             'B' :                 {cud}
  314.               Begin
  315.                 If ParamArr[1] = 0 Then ParamArr[1] := 1;
  316.                 If (Wherey + ParamArr[1] <= Hi(WindMax))
  317.                 Then GotoXy(WhereX, Wherey + ParamArr[1])
  318.                 Else GotoXy(WhereX, 1);
  319.               End;
  320.             'C' :                 {cuf}
  321.               Begin
  322.                 If ParamArr[1] = 0 Then ParamArr[1] := 1;
  323.                 If WhereX + ParamArr[1] <= Lo(WindMax)
  324.                 Then GotoXy(WhereX + ParamArr[1], Wherey)
  325.                 Else GotoXy(Lo(WindMax), Wherey);
  326.               End;
  327.             'D' :                 {cub}
  328.               Begin
  329.                 If ParamArr[1] = 0 Then ParamArr[1] := 1;
  330.                 If (WhereX - ParamArr[1] >= 1)
  331.                 Then GotoXy(WhereX - ParamArr[1], Wherey)
  332.                 Else GotoXy(1, Wherey);
  333.               End;
  334.             'H', 'f' :            {cup,hvp}
  335.               Begin
  336.                 If ParamArr[1] = 0 Then ParamArr[1] := 1;
  337.                 If ParamArr[2] = 0 Then ParamArr[2] := 1;
  338.                 GotoXy(ParamArr[2], ParamArr[1]);
  339.               End;
  340.             'J' :                 {EID}
  341.               Case ParamArr[1] Of
  342.                 2 : ClrScr;
  343.                 0 :               {ClrEos}
  344.                   Begin
  345.                     ClrEol;
  346.                     ScrollWindowDown(Lo(WindMin) + 1, Hi(WindMin) + Wherey + 1,
  347.                                      Lo(WindMax) + 1, Hi(WindMax) + 1, 0);
  348.                   End;
  349.                 1 :               {Clear from beginning of screen}
  350.                   Begin
  351.                     ScrollWindowDown(Lo(WindMin) + 1, Hi(WindMin) + Wherey,
  352.                                      Lo(WindMin) + WhereX,
  353.                                      Hi(WindMin) + Wherey, 0);
  354.                     ScrollWindowDown(Lo(WindMin) + 1, Hi(WindMin) + 1,
  355.                                      Lo(WindMax) + 1, Hi(WindMin) + Wherey - 1, 0);
  356.                   End;
  357.               End {Case} ;
  358.             'K' :                 {eil}
  359.               Case ParamArr[1] Of
  360.                 0 : ClrEol;
  361.                 1 :               { clear from beginning of line to cursor }
  362.                   ScrollWindowDown(Lo(WindMin) + 1, Hi(WindMin) + Wherey,
  363.                                    Lo(WindMin) + WhereX - 1,
  364.                                    Hi(WindMin) + Wherey, 0);
  365.                 2 :               { clear entire line }
  366.                   ScrollWindowDown(Lo(WindMin) + 1, Hi(WindMin) + Wherey,
  367.                                    Lo(WindMax) + 1,
  368.                                    Hi(WindMin) + Wherey, 0);
  369.               End {Case ParamArr} ;
  370.             'L' : {il } For i := 1 To ParamArr[1] Do InsLine; { must not move cursor }
  371.             'M' : {d_l} For i := 1 To ParamArr[1] Do DelLine; { must not move cursor }
  372.             'P' :                 {dc }
  373.               Begin
  374.               End;
  375.             'R' :                 {cpr}
  376.               Begin
  377.                 ReportedY := ParamArr[1];
  378.                 ReportedX := ParamArr[2];
  379.               End;
  380.             '@' :                 {ic}
  381.               Begin
  382.                 { insert blank chars }
  383.               End;
  384.             'h', 'l' :            {sm/rm}
  385.               Case ParamArr[1] Of
  386.                 0 : TextMode(BW40);
  387.                 1 : TextMode(CO40);
  388.                 2 : TextMode(BW80);
  389.                 3 : TextMode(CO80);
  390.                 4 : {GraphMode(320x200 col)} ;
  391.                 5 : {GraphMode(320x200 BW)} ;
  392.                 6 : {GraphMode(640x200 BW)} ;
  393.                 7 : Wrap := Ch = 'h';
  394.               End {case} ;
  395.             'n' :                 {dsr}
  396.               If (ParamArr[1] = 6) Then
  397.                 ReplyHook(#27'[' + Long2str(Wherey) + ';' +
  398.                           Long2str(WhereX) + 'R');
  399.             's' :                 {scp}
  400.               Begin
  401.                 SavedX := WhereX;
  402.                 SavedY := Wherey;
  403.               End;
  404.             'u' : {rcp} GotoXy(SavedX, SavedY);
  405.             'p' :                 {keyboard reassignment}
  406.               KeyHook(St);
  407.             Else
  408.               Begin
  409.                 If (Ch > ' ') Then Write(Ch)
  410.                 Else WriteHook(Ch);
  411.                 Exit;
  412.               End;
  413.           End {Case Ch} ;
  414.         End;
  415.       {$IFDEF Music}
  416.       Get_Music :
  417.         Begin
  418.           If Ch <> #3             {Ctrl-C}
  419.           Then St := St + Ch
  420.           Else
  421.           Begin
  422.             NextState := Waiting;
  423.             PlayHook(St);
  424.           End;
  425.         End;
  426.       {$ENDIF}
  427.     End {Case NextState} ;
  428.   End {AnsiWrite} ;
  429.  
  430.   {$IFNDEF Small}
  431.  
  432.   {$F+}                           { All Driver function must be far }
  433.  
  434.   Function Nothing(Var f : TextRec) : Integer;
  435.   Begin
  436.     Nothing := 0;
  437.   End {Nothing} ;
  438.  
  439.   Procedure Null(Ch : Char);
  440.   Begin
  441.     {}
  442.   End {Null} ;
  443.  
  444.   Function DevOutput(Var f : TextRec) : Integer;
  445.   Var
  446.     i                   : Integer;
  447.   Begin
  448.     With f Do
  449.     Begin
  450.       { f.BufPos contains the number of chars in the buffer }
  451.       { f.BufPtr^ is your buffer                            }
  452.       { Any variable conversion done by writeln is already  }
  453.       { done by now.                                        }
  454.       i := 0;
  455.       While i < BufPos Do
  456.       Begin
  457.         AnsiWrite(BufPtr^[i]);
  458.         {$IFDEF BBS}
  459.         BBSHook(BufPtr^[i]);
  460.         {$ENDIF}
  461.         Inc(i);
  462.       End;
  463.       BufPos := 0;
  464.     End;
  465.     DevOutput := 0;               { return IOResult Error codes here }
  466.   End {DevOutput} ;
  467.  
  468.   Function DevOpen(Var f : TextRec) : Integer;
  469.   Begin
  470.     With f Do
  471.     Begin
  472.       If Mode = FmInput Then
  473.       Begin
  474.         InOutFunc := @Nothing;
  475.         FlushFunc := @Nothing;
  476.       End
  477.       Else
  478.       Begin
  479.         Mode := FmOutput;         { in case it was FmInOut }
  480.         InOutFunc := @DevOutput;
  481.         FlushFunc := @DevOutput;
  482.       End;
  483.       CloseFunc := @Nothing;
  484.     End;
  485.     DevOpen := 0;                 { return IOResult error codes here }
  486.   End {DevOpen} ;
  487.  
  488.   Procedure AssignAnsi(Var f : Text);
  489.   Begin
  490.     FillChar(f, SizeOf(f), #0);   { init file var }
  491.     With TextRec(f) Do
  492.     Begin
  493.       Handle := $ffff;
  494.       Mode := FmClosed;
  495.       BufSize := SizeOf(Buffer);
  496.       BufPtr := @Buffer;
  497.       OpenFunc := @DevOpen;
  498.       Name[0] := #0;
  499.     End;
  500.   End {AssignAnsi} ;
  501.   {$ENDIF}
  502.  
  503. Begin
  504.  
  505.   {$IFNDEF Small}
  506.  
  507.   AssignAnsi(Ansi);               { set up the variable }
  508.   Rewrite(Ansi);                  { open it for output  }
  509.  
  510.   {$IFDEF BBS}
  511.  
  512.     BBsHook := Null;
  513.  
  514.   {$ENDIF}
  515.   {$ENDIF}
  516.  
  517.   Wrap := True;
  518.   ReplyHook := Report;
  519.   KeyHook := Dummy;
  520.   WriteHook := WriteChar;
  521.  
  522.   {$IFDEF Music}
  523.  
  524.   PlayHook := Dummy; { point play into the great music heaven }
  525.  
  526.   {$ENDIF}
  527. End.
  528.